home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-bcklg.el.z / gnus-bcklg.el
Encoding:
Text File  |  1998-05-21  |  4.9 KB  |  155 lines
  1. ;;; gnus-bcklg.el --- backlog functions for Gnus
  2. ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.     See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;;; Code:
  27.  
  28. (eval-when-compile (require 'cl))
  29.  
  30. (require 'gnus)
  31.  
  32. ;;;
  33. ;;; Buffering of read articles.
  34. ;;;
  35.  
  36. (defvar gnus-backlog-buffer " *Gnus Backlog*")
  37. (defvar gnus-backlog-articles nil)
  38. (defvar gnus-backlog-hashtb nil)
  39.  
  40. (defun gnus-backlog-buffer ()
  41.   "Return the backlog buffer."
  42.   (or (get-buffer gnus-backlog-buffer)
  43.       (save-excursion
  44.     (set-buffer (get-buffer-create gnus-backlog-buffer))
  45.     (buffer-disable-undo (current-buffer))
  46.     (setq buffer-read-only t)
  47.     (gnus-add-current-to-buffer-list)
  48.     (get-buffer gnus-backlog-buffer))))
  49.  
  50. (defun gnus-backlog-setup ()
  51.   "Initialize backlog variables."
  52.   (unless gnus-backlog-hashtb
  53.     (setq gnus-backlog-hashtb (gnus-make-hashtable 1024))))
  54.  
  55. (gnus-add-shutdown 'gnus-backlog-shutdown 'gnus)
  56.  
  57. (defun gnus-backlog-shutdown ()
  58.   "Clear all backlog variables and buffers."
  59.   (when (get-buffer gnus-backlog-buffer)
  60.     (kill-buffer gnus-backlog-buffer))
  61.   (setq gnus-backlog-hashtb nil
  62.     gnus-backlog-articles nil))
  63.  
  64. (defun gnus-backlog-enter-article (group number buffer)
  65.   (gnus-backlog-setup)
  66.   (let ((ident (intern (concat group ":" (int-to-string number))
  67.                gnus-backlog-hashtb))
  68.     b)
  69.     (if (memq ident gnus-backlog-articles)
  70.     ()                ; It's already kept.
  71.       ;; Remove the oldest article, if necessary.
  72.       (and (numberp gnus-keep-backlog)
  73.        (>= (length gnus-backlog-articles) gnus-keep-backlog)
  74.        (gnus-backlog-remove-oldest-article))
  75.       (push ident gnus-backlog-articles)
  76.       ;; Insert the new article.
  77.       (save-excursion
  78.     (set-buffer (gnus-backlog-buffer))
  79.     (let (buffer-read-only)
  80.       (goto-char (point-max))
  81.       (unless (bolp)
  82.         (insert "\n"))
  83.       (setq b (point))
  84.       (insert-buffer-substring buffer)
  85.       ;; Tag the beginning of the article with the ident.
  86.       (gnus-put-text-property b (1+ b) 'gnus-backlog ident))))))
  87.  
  88. (defun gnus-backlog-remove-oldest-article ()
  89.   (save-excursion
  90.     (set-buffer (gnus-backlog-buffer))
  91.     (goto-char (point-min))
  92.     (if (zerop (buffer-size))
  93.     ()                ; The buffer is empty.
  94.       (let ((ident (get-text-property (point) 'gnus-backlog))
  95.         buffer-read-only)
  96.     ;; Remove the ident from the list of articles.
  97.     (when ident
  98.       (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
  99.     ;; Delete the article itself.
  100.     (delete-region
  101.      (point) (next-single-property-change
  102.           (1+ (point)) 'gnus-backlog nil (point-max)))))))
  103.  
  104. (defun gnus-backlog-remove-article (group number)
  105.   "Remove article NUMBER in GROUP from the backlog."
  106.   (when (numberp number)
  107.     (gnus-backlog-setup)
  108.     (let ((ident (intern (concat group ":" (int-to-string number))
  109.              gnus-backlog-hashtb))
  110.       beg end)
  111.       (when (memq ident gnus-backlog-articles)
  112.     ;; It was in the backlog.
  113.     (save-excursion
  114.       (set-buffer (gnus-backlog-buffer))
  115.       (let (buffer-read-only)
  116.         (when (setq beg (text-property-any
  117.                  (point-min) (point-max) 'gnus-backlog
  118.                  ident))
  119.           ;; Find the end (i. e., the beginning of the next article).
  120.           (setq end
  121.             (next-single-property-change
  122.              (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
  123.           (delete-region beg end)
  124.           ;; Return success.
  125.           t)))))))
  126.  
  127. (defun gnus-backlog-request-article (group number buffer)
  128.   (when (numberp number)
  129.     (gnus-backlog-setup)
  130.     (let ((ident (intern (concat group ":" (int-to-string number))
  131.              gnus-backlog-hashtb))
  132.       beg end)
  133.       (when (memq ident gnus-backlog-articles)
  134.     ;; It was in the backlog.
  135.     (save-excursion
  136.       (set-buffer (gnus-backlog-buffer))
  137.       (if (not (setq beg (text-property-any
  138.                   (point-min) (point-max) 'gnus-backlog
  139.                   ident)))
  140.           ;; It wasn't in the backlog after all.
  141.           (ignore
  142.            (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
  143.         ;; Find the end (i. e., the beginning of the next article).
  144.         (setq end
  145.           (next-single-property-change
  146.            (1+ beg) 'gnus-backlog (current-buffer) (point-max)))))
  147.     (let ((buffer-read-only nil))
  148.       (erase-buffer)
  149.       (insert-buffer-substring gnus-backlog-buffer beg end)
  150.       t)))))
  151.  
  152. (provide 'gnus-bcklg)
  153.  
  154. ;;; gnus-bcklg.el ends here
  155.